home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / menu enhancements / marking-menu-demo.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  21.6 KB  |  519 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;marking-menu-demo.lisp
  3. ;;
  4. ;; Copyright © 1992 University of Toronto, Department of Computer Science
  5. ;; All Rights Reserved
  6. ;;
  7. ;; author: Mark A. Tapia
  8. ;;
  9. ;; A demonstration of marking menus
  10. ;;
  11. ;; To use this demonstration, first load "init-menus.lisp"
  12. ;; and then evaluate the form:
  13. ;;  (menus::load-marking-demo)
  14. ;; Finally evalute the form:
  15. ;;  (marking-demo)
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17.  
  18. (in-package cl-user)
  19. (eval-when (eval compile)
  20.   (require 'oou-utils)
  21.   (require 'marking-menus)
  22.   (require 'check-menus))
  23. (use-package 'menus)
  24. (import '(menus::queued-modal-dialog menus::containing-view))
  25.  
  26. (defvar *floating* t "Floating menus?")
  27. (defvar *opaque* nil "Opaque menus?")
  28. (defvar *custom* nil)
  29. (defparameter default-font '("Times" 14 :srcor :plain))
  30. (defvar *testing* nil)
  31.  
  32.  
  33. (defmacro stack-toplevel (new-level &rest body)
  34.   `(let ((old-level (%set-toplevel)))
  35.      (unwind-protect 
  36.        (progn
  37.          (%set-toplevel ,new-level)
  38.          ,@body)
  39.        (%set-toplevel old-level))))
  40.  
  41. (defmethod get-menu-options ((view marking-menu-view))
  42.   ;; set the menu defaults for the marking-menu-view
  43.   (setf (slot-value view 'menus::menu-floating) *floating*
  44.         (slot-value view 'menus::menu-opaque) *opaque*))
  45.  
  46. ;; nested-window
  47. ;; a specialized version of a marking-menu--window
  48. ;; There are 6 menus items in the main view
  49. ;;   beep       to beep
  50. ;;   zoom       simulates clicking on the window zoom box
  51. ;;   disabled   a disabled menu item that does nothing, in bold
  52. ;;   close      simulates a click on the close box
  53. ;;   check      a menu-item with the checkmark character
  54. ;;   -          an empty item
  55.  
  56. ;; The view contains a subview of class marking-text-view, a marking menu view
  57.  
  58. (defclass nested-window (marking-menu-window)
  59.   ()
  60.   (:default-initargs :window-title "Nested marking-views"
  61.     :menu-diameter 185
  62.     :menu-floating *floating*
  63.     :menu-opaque *opaque*
  64.     :menu-font default-font
  65.     :auto-size t))
  66.  
  67.  
  68. ;; Marking menu functions associated with a nested-window
  69. (defmethod zoom-it ((self window))
  70.   ;; similates clicking on the zoom-box for the window
  71.   (window-zoom-event-handler self 
  72.                              (if (equal (view-size self) (window-default-zoom-size self))
  73.                                7
  74.                                8)))
  75.  
  76.  
  77. ;; Text associated with a subview of a nested window
  78. (defvar help-1
  79.   (format nil
  80.           "Press the mouse button down in the window.~
  81.            Wait till the menu appears. ~
  82.            To select an item release the button. ~
  83.            To cancel, release in the center. ~
  84.            Items that can be chosen are hilited. ~
  85.            You'll leave a rubber band where you go.
  86.  
  87. Page 1/2"))
  88.  
  89. (defvar help-2
  90.       (format nil
  91.       "When you've practiced, don't wait, just make a mark and you'll leave an ink trail. ~
  92.        You can make marks outside the window. ~
  93.        Whenever you wait, the menu will pop up. ~
  94.        The menu here is not the same as the one outside the box.
  95.  
  96. Page 2/2"))
  97.  
  98. ;; A marking-menu-view which is a subview of a nested window
  99. ;;   the view contains a check-box-dialog-item and a static-text-dialog-item 
  100. (defclass marking-text (marking-menu-view static-text-dialog-item)
  101.   ;; a marking-menu-view which is also a text dialog item with a frame around it.
  102.   ()
  103.   (:default-initargs :view-position #@(10 10)
  104.     :view-nick-name 'box
  105.     :view-size  #@(300 120)
  106.     :menu-font default-font
  107.     :view-font '("Times" 14 :srccopy :plain)
  108.     :menu-floating *floating*
  109.     :menu-opaque *opaque*
  110.     :auto-size t))
  111.  
  112. (defmethod view-draw-contents ((view marking-text))
  113.   ;; specialized method for drawing a marking-text,
  114.   ;; draws a frame around the view
  115.   (call-next-method view)
  116.   (with-focused-view view
  117.     (rlet ((rect :rect :topLeft #@(0 0)
  118.                  :bottomRight (view-size view)))
  119.       (#_framerect :ptr rect))))
  120.  
  121. (defmethod initialize-instance :after ((view marking-text) &rest initargs)
  122.   (declare (ignore initargs))
  123.   (let (text-box check next previous check-box)
  124.     (get-menu-options view)
  125.     
  126.     (setq text-box                  ; add an indented text box indented 
  127.           (make-instance 'static-text-dialog-item 
  128.                          :view-size (subtract-points (view-size view) #@(10 10))
  129.                          :view-position #@(5 5)
  130.                          :view-nick-name 'help
  131.                          :view-font (view-font view)
  132.                          :dialog-item-text help-1)
  133.           
  134.           check-box             ; and a check-box-dialog-item
  135.           (make-instance 'check-box-dialog-item
  136.                          :view-font (view-font view)
  137.                          :view-size #@(70 15)
  138.                          :view-position #@(220 100)
  139.                          :view-nick-name 'check-box
  140.                          :dialog-item-text "Inner"))
  141.     
  142.     ;; create three menu items, one to demonstrate check marks, and two to
  143.     ;; move forward/backwards through the help text
  144.     (setq check (make-instance 'check-window-menu-item
  145.                                :menu-item-title "Check"
  146.                                :mark "√")
  147.           
  148.           next (make-instance 'window-menu-item 
  149.                               :menu-item-title "Next")
  150.           
  151.           previous (make-instance 'window-menu-item 
  152.                                   :menu-item-title "Prev"
  153.                                   :disabled t))
  154.     
  155.     (setf (dialog-item-action-function check-box)
  156.           #'(lambda (item)
  157.               (let ((container (view-container item)))
  158.               (set-menu-item-check-mark (find-menu-item container "Check")
  159.                                         (check-box-checked-p item))))
  160.           
  161.           (menu-item-action-function check)
  162.           #'(lambda (item)
  163.               (let* ((container (containing-view item))
  164.                      (check-bx (view-named 'check-box container))
  165.                      (checked (check-box-checked-p check-bx)))
  166.                 (eval-enqueue `(check-another ,check-bx (not ,checked)))))
  167.           
  168.           (menu-item-action-function previous)
  169.           #'(lambda (item)
  170.               (let* ((container (containing-view item))
  171.                     (nxt (find-menu-item container "Next")))
  172.                 (set-dialog-item-text (view-named 'help container) help-1)
  173.                 (menu-item-disable item)
  174.                 (menu-item-enable nxt)))
  175.           
  176.           (menu-item-action-function next)
  177.           #'(lambda (item)
  178.               (let* ((container (containing-view item))
  179.                      (prev (find-menu-item container "Prev")))
  180.                 (set-dialog-item-text (view-named 'help container) help-2)
  181.                 (menu-item-disable item)
  182.                 (menu-item-enable prev))))
  183.     
  184.     (add-subviews view text-box check-box)
  185.     (add-menu-items view check next previous))) 
  186.  
  187. (defmethod initialize-instance :after ((view nested-window) &rest initargs)
  188.   (declare (ignore initargs))
  189.   (let (beep zoom disabled close check null-item check-box)
  190.     (declare (ignore initargs))
  191.     (get-menu-options view)
  192.     (add-subviews view (make-instance 'marking-text))
  193.     ;; add a menu with 6 menu-items to the view
  194.     ;;   beep       to beep
  195.     ;;   zoom       click on window the zoom box
  196.     ;;   disabled   for a disabled menu item that does nothing, in bold
  197.     ;;   close      click on the close box
  198.     ;;   check      a menu-item with the checkmark character
  199.     ;;   -          an empty item
  200.     (setq check-box (make-instance 'check-box-dialog-item
  201.                                    :view-font (view-font view)
  202.                                    :view-nick-name 'checker
  203.                                    :view-size #@(70 15)
  204.                                    :view-position #@(400 20)
  205.                                    :dialog-item-text "Outer")
  206.           
  207.           beep (make-instance 'menu-item 
  208.                               :menu-item-title "Beep"
  209.                               :menu-item-action #'(lambda ()
  210.                                                     (#_sysBeep :integer 1)))
  211.           
  212.           zoom (make-instance 'window-menu-item 
  213.                               :menu-item-title "Zoom"
  214.                               :style :italic
  215.                               :menu-item-action
  216.                               #'(lambda (item)
  217.                                   (zoom-it (containing-view item))))
  218.           
  219.           disabled (make-instance 'menu-item 
  220.                                   :menu-item-title "Disabled"
  221.                                   :disabled t
  222.                                   :style :bold)
  223.           
  224.           close (make-instance 'window-menu-item 
  225.                                :menu-item-title "Close"
  226.                                :menu-item-action #'(lambda (item)
  227.                                                      (let ((container (containing-view item)))
  228.                                                        (eval-enqueue
  229.                                                         `(window-close ,container)))))
  230.           
  231.           check (make-instance 'check-window-menu-item
  232.                                :menu-item-title "Check"
  233.                                :mark "√")
  234.           
  235.           null-item (make-instance 'empty-menu-item))
  236.     
  237.     (setf (dialog-item-action-function check-box)
  238.           #'(lambda (item)
  239.               (let ((container (view-container item)))
  240.                 (set-menu-item-check-mark (find-menu-item container "Check")
  241.                                           (check-box-checked-p item))))
  242.           
  243.           (menu-item-action-function check)
  244.           #'(lambda (item)
  245.               (let* ((container (containing-view item))
  246.                      (check-bx (view-named 'checker container))
  247.                      (checked (check-box-checked-p check-bx)))
  248.                 (eval-enqueue `(check-another ,check-bx (not ,checked))))))
  249.               
  250.     (add-subviews view check-box)
  251.     (add-menu-items view beep zoom disabled close check null-item)))
  252.  
  253. (defmethod check-another ((dialog-item check-box-dialog-item) flag)
  254.   (if flag
  255.     (check-box-check dialog-item)
  256.     (check-box-uncheck dialog-item)))
  257.  
  258. ;;  Define a class of marking-menu-table, a sequence dialog item
  259. ;;  with three menu items
  260. ;;   Next          to skip forward through the list of numbers (0 - 10)
  261. ;;   Prev          to skip backward through the list of numbers (0 - 10)
  262. ;;   Examine       to print an English representation of the number in the list
  263. ;;
  264. ;; The double-click-action is equivalent to Examine.
  265.  
  266. (defclass menu-table (marking-menu-table)
  267.   ()
  268.   (:default-initargs
  269.     :table-dimensions 11
  270.     :view-position   #@(50 50) 
  271.     :view-size  #@(112 31) 
  272.     :CELL-SIZE #@(28 16) 
  273.     :TABLE-HSCROLLP T 
  274.     :TABLE-VSCROLLP NIL
  275.     :sequence-order :horizontal
  276.     :view-position #@(10 50)
  277.     :on-axis nil
  278.     :view-size #@(123 46)
  279.     :menu-diameter 165
  280.     :menu-font default-font
  281.     :menu-floating *floating*
  282.     :menu-opaque *opaque*
  283.     :auto-size t))
  284.  
  285. (defmethod scroll-forward ((self table-dialog-item))
  286.   (let* ((first-cell (point-h (scroll-position self)))
  287.          (ncells (point-h (table-dimensions self)))
  288.          (visible-dimensions (point-h (visible-dimensions self)))
  289.          (last-cell (min (1- (+ first-cell visible-dimensions))
  290.                          (- ncells visible-dimensions))))
  291.     (when (< last-cell ncells)
  292.       (scroll-to-cell self last-cell)
  293.       (< (+ last-cell visible-dimensions) ncells))))
  294.  
  295. (defmethod scroll-backward ((self table-dialog-item))
  296.   (let* ((first-cell (point-h (scroll-position self)))
  297.          (visible-dimensions (point-h (visible-dimensions self)))
  298.          new-cell)
  299.     (setq new-cell (max 0 (1+ (- first-cell visible-dimensions))))
  300.     (scroll-to-cell self new-cell)
  301.     (not (zerop new-cell))))
  302.  
  303. (defmethod initialize-instance :after ((marking-menu-table menu-table) &rest initargs)
  304.   (declare (ignore initargs))
  305.   (let (forward backward (self marking-menu-table) close)
  306.     (get-menu-options marking-menu-table)
  307.     (set-table-sequence self '(0 1 2 3 4 5 6 7 8 9 10))
  308.     ;; create two menu items to
  309.     ;; move forward and backwards
  310.     (setq forward (make-instance 'window-menu-item
  311.                                  :menu-item-title "Next")
  312.           close (make-instance 'window-menu-item
  313.                                :menu-item-title "Close"
  314.                                :menu-item-action #'(lambda (item)
  315.                                                      (let* ((container (containing-view item))
  316.                                                             (window (view-window container)))
  317.                                                        (eval-enqueue
  318.                                                         `(window-close ,window)))))
  319.           
  320.           backward (make-instance 'window-menu-item
  321.                                   :disabled t
  322.                                   :menu-item-title "Prev"))
  323.     
  324.     (add-menu-items self forward close backward)
  325.     
  326.     (setf (menu-item-action-function forward)
  327.           #'(lambda (item)
  328.               (let ((container (containing-view item)))
  329.                 (eval-enqueue
  330.                  `(progn
  331.                     (unless (scroll-forward ,container)
  332.                       (menu-item-disable (find-menu-item ,container "Next")))
  333.                     (menu-item-enable (find-menu-item ,container "Prev"))))))
  334.           
  335.           (menu-item-action-function backward)
  336.           #'(lambda (item)
  337.               (let ((container (containing-view item)))
  338.                 (eval-enqueue
  339.                  `(progn
  340.                     (unless (scroll-backward ,container)
  341.                       (menu-item-disable (find-menu-item ,container "Prev")))
  342.                     (menu-item-enable (find-menu-item ,container "Next")))))))))
  343.  
  344. ;; create a window which contains a menu-table
  345. (defclass table-window (window)
  346.   ()
  347.   (:default-initargs
  348.     :Window-title "Table dialog demo"
  349.     :window-type :document-with-grow
  350.     :view-position #@(50 50) 
  351.     :view-size #@(300 100) 
  352.     :view-font '("Chicago" 12 :SRCOR :PLAIN)))
  353.  
  354. (defmethod initialize-instance :after ((self table-window) &rest initargs)
  355.   (declare (ignore initargs))
  356.   (let (new-table textb examine items)
  357.     (setq new-table (make-instance 'menu-table)
  358.           
  359.           examine (make-instance 'window-menu-item
  360.                                  :menu-item-title "Examine")
  361.           
  362.           textb (make-instance 'static-text-dialog-item
  363.                                :view-size #@(80 30)
  364.                                :view-position #@(50 10)
  365.                                :view-nick-name 'text
  366.                                :view-font '("Times" 24 :srcor :plain)
  367.                                :dialog-item-text "Nothing"))
  368.     
  369.     (add-subviews self new-table textb)
  370.     (setq items (menu-items new-table))
  371.     (mapcar #'(lambda (item) (remove-menu-items new-table item)) items)
  372.     (push examine items)
  373.     (mapcar #'(lambda (item) (add-menu-items new-table item)) items)
  374.     
  375.     (setf (menu-item-action-function examine)
  376.           #'(lambda (item)
  377.               (let ((table (containing-view item))
  378.                     (text (find-named-sibling new-table 'text)))
  379.                 (set-dialog-item-text 
  380.                  text
  381.                  (format nil "~r" (cell-contents new-table
  382.                                                  (first (selected-cells table)))))))
  383.           
  384.           (slot-value new-table 'menus::menu-double-click-action-function)
  385.           #'(lambda (item) 
  386.               (let ((table (containing-view item))
  387.                     (text (find-named-sibling new-table 'text)))
  388.                 (set-dialog-item-text 
  389.                  text
  390.                  (format nil "~r" (cell-contents table
  391.                                                  (first (selected-cells table))))))))))
  392.  
  393. (defun nested-demo ()
  394.   (queued-modal-dialog (make-instance 'nested-window)))
  395.  
  396. (defun table-demo ()
  397.   (queued-modal-dialog (make-instance 'table-window)))
  398.  
  399. ;;  Create a dialog window with a menu with 6 items:
  400. ;;    Nested      to demonstrate nested marking menus (class nested-window)
  401. ;;    Table       to demonstrate marking-menu-table
  402. ;;    -           an empty emnu item
  403. ;;    Floating    a check-menu-item: use floating menus when checked
  404. ;;    Opaque      a check-menu-item: use opaque menus when checked 
  405. ;;                and when floating is also checked
  406. ;;    Quit        to end the demonstration
  407. (defclass marking-dialog (marking-menu-window)
  408.   ()
  409.   (:default-initargs
  410.     :window-type :shadow-edge-box 
  411.     :view-position :centered
  412.     :view-size #@(311 169)
  413.     :on-axis nil
  414.     :close-box-p nil
  415.     :view-font '("Chicago" 12 :srcor :plain)
  416.     :menu-font default-font
  417.     :menu-diameter 210
  418.     :menu-floating *floating*
  419.     :menu-opaque *opaque*
  420.     :auto-size t))
  421.  
  422. (defmethod initialize-instance :after ((view marking-dialog) &rest init-args)
  423.   (declare (ignore init-args))
  424.   (let ((floating (make-instance 'check-menu-item 
  425.                                  :menu-item-title "Floating"
  426.                                  :mark "√"))
  427.         (opaque (make-instance 'check-menu-item 
  428.                                :menu-item-title "Opaque"
  429.                                :mark "√")))
  430.     (get-menu-options view)
  431.     (setf (menu-item-action-function floating)
  432.           #'(lambda ()
  433.               (let ((checked 
  434.                      (menu-item-check-mark floating))) 
  435.                 (setq *floating* checked)
  436.                 (if checked
  437.                   (menu-item-enable opaque)
  438.                   (progn (menu-item-disable opaque)
  439.                          (set-menu-item-check-mark opaque nil)
  440.                          (setf (slot-value view 'menus::menu-opaque)
  441.                                nil)
  442.                          (setq *opaque* nil)))
  443.                 (eval-enqueue `(setf (slot-value ,view 'menus::menu-floating)
  444.                                      ,checked))))
  445.           (menu-item-action-function opaque)
  446.           #'(lambda ()
  447.               (let ((checked 
  448.                      (menu-item-check-mark opaque))) 
  449.                 (setq *opaque* checked)
  450.                 (setf (slot-value view 'menus::menu-opaque)
  451.                       checked))))
  452.     (set-menu-item-check-mark floating *floating*)
  453.     (set-menu-item-check-mark opaque *opaque*)
  454.     (unless *floating*
  455.       (menu-item-disable opaque))
  456.     (add-subviews  view 
  457.                    (make-instance 'static-text-dialog-item 
  458.                                   :view-position #@(49 34)
  459.                                   :view-size  #@(223 60) 
  460.                                   :dialog-item-text "Hold the mouse button down to try marking menus. Experiment with the options." 
  461.                                   :view-font '("Chicago" 12 :srccopy :plain)))
  462.     (add-menu-items view
  463.                     (make-instance 'window-menu-item 
  464.                                    :menu-item-title "Nested"
  465.                                    :menu-item-action #'(lambda (item)
  466.                                                          (let ((container (containing-view item)))
  467.                                                            (eval-enqueue
  468.                                                             `(progn
  469.                                                                (window-hide ,container)
  470.                                                                (nested-demo)
  471.                                                                (window-select ,container))))))
  472.                     (make-instance 'window-menu-item 
  473.                                    :menu-item-title "Table"
  474.                                    :menu-item-action #'(lambda (item) 
  475.                                                          (let ((container (containing-view item)))
  476.                                                            (eval-enqueue
  477.                                                             `(progn 
  478.                                                                (window-hide ,container)
  479.                                                                (table-demo)
  480.                                                                (window-select ,container))))))
  481.                     floating
  482.                     opaque
  483.                     (make-instance 'window-menu-item 
  484.                                    :menu-item-title "Quit"
  485.                                    :menu-item-action #'(lambda (item)
  486.                                                          (let ((container (containing-view item)))
  487.                                                            (eval-enqueue `(window-close ,container)))))
  488.                     
  489.                     (if *custom*
  490.                       (make-instance 'window-menu-item 
  491.                                      :menu-item-title "Graphic"
  492.                                      :menu-item-action #'(lambda (item)
  493.                                                            (let ((container (containing-view item)))
  494.                                                              (eval-enqueue
  495.                                                               `(progn 
  496.                                                                  (window-hide ,container)
  497.                                                                  (queued-modal-dialog (make-instance 'gdemo-window :window-show t))
  498.                                                                  (window-select ,container))))))
  499.                       (make-instance 'empty-menu-item))
  500.                     )))
  501.  
  502. (defun marking-demo ()
  503.   (queued-modal-dialog (make-instance 'marking-dialog)))
  504.  
  505. (defun make-marking-demo ()
  506.   "Create the experiment application"
  507.   (let ((target-appl (choose-new-file-dialog :directory "ccl;marking-menus")))
  508.     (setq *testing* nil)
  509.     (set-menubar nil)
  510.     (save-application target-appl
  511.                       :excise-compiler t    ; don't want the compiler
  512.                       :clear-clos-caches nil ; otherwise we can't access classes 
  513.                       :toplevel-function #'marking-demo)))
  514.  
  515. #|
  516. ; (make-marking-demo) to create an application
  517. |#
  518.  
  519.